home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / midipeek.zip / MIDIPEEK.PAS < prev    next >
Pascal/Delphi Source File  |  1988-09-04  |  9KB  |  367 lines
  1. {$R-}    {Range checking off}
  2. {$B+}    {Boolean complete evaluation on}
  3. {$S+}    {Stack checking on}
  4. {$I-}    {I/O checking OFF}
  5. {$N-}    {No numeric coprocessor}
  6. {$M 65500,16384,655360} {Turbo 3 default stack and heap}
  7.  
  8. { Copyright (c) 1986, 1987, 1988 Carter Scholz }
  9.  
  10. { You may copy and distribute this program freely for NON-COMMERCIAL use
  11.   only.  If you have received this program for free, and find it useful
  12.   or educational, a $15 donation is suggested. }
  13.  
  14. { works fine EXCEPT that running from EXE after the first time
  15.   exits w/o waiting for a "quit"
  16.   Revise so that "filtering" is an option rather than a forced
  17.   query?
  18. }
  19.  
  20.  
  21. uses Crt, Mpu;
  22.  
  23. const
  24.   MaxBuf=$7FFF;     {limits buffer to 32K}
  25.   version='2.0';
  26.  
  27. var
  28.   ch:char;
  29.   i, LastByte : integer;
  30.   Midijunk: byte;
  31.   j, MidiCh, BytesLeft, statbytes, laststat : integer;
  32.   buffer: array [0 .. MaxBuf] of byte;
  33.   PrintFlag, answer: char;
  34.   ActiveIgnore : Boolean;
  35.   SysEx, NoteOn, Quit, done, stattocome, comingback : Boolean;
  36.   FileName: string;
  37.   MidiFile: file of byte;
  38.   AFilter,BFilter,CFilter,DFilter,EFilter,FFilter,NFilter: boolean;
  39.  
  40. function Exist (filename:string) : Boolean;
  41.   var
  42.     testfile: file;
  43.   begin
  44.     assign (testfile,filename);
  45.     reset (testfile);
  46.     if (IOresult=0) then
  47.       begin
  48.         exist := true;
  49.         close(testfile);
  50.       end
  51.       else
  52.       exist := false;
  53.   end;
  54.  
  55.  
  56. function HexString(b:integer):string;
  57.   const
  58.     hex : array [0..15] of char = '0123456789ABCDEF';
  59.   begin
  60.     HexString := hex [b shr 4] + hex [b and 15];
  61.   end;
  62.  
  63. procedure Hello;
  64.   var ch:char;
  65.   begin
  66.     clrscr;
  67.     writeln;
  68.     writeln;
  69.     writeln;
  70.     writeln;
  71.     HighVideo;
  72.     writeln('    PEEK');
  73.     writeln;
  74.     writeln('    version ',version);
  75.     LowVideo;
  76.     writeln;
  77.     writeln;
  78.     writeln;
  79.     writeln('              a MIDI monitor program for MPU-401 interface');
  80.     writeln;
  81.     writeln;
  82.     writeln('              copyright 1986-88 Carter Scholz');
  83.     writeln;
  84.     writeln;
  85.     writeln;
  86.     writeln;
  87.     writeln('    Carter Scholz, 2665 Virginia St., Berkeley CA 94709.');
  88.     writeln;
  89.     writeln;
  90.     writeln('    Press any key to continue.');
  91.     ch:=readkey;
  92.     clrscr;
  93.   end;
  94.  
  95. procedure InitFilters;
  96.   begin
  97.      Afilter:=false;
  98.      Bfilter:=false;
  99.      Cfilter:=false;
  100.      Dfilter:=false;
  101.      EFilter:=false;
  102.      Ffilter:=false;
  103.      Nfilter:=false;
  104.   end;
  105.  
  106. procedure ShowFilters;
  107.   begin
  108.       window(1,25,80,25);
  109.       clrscr;
  110.       write ('Filtering:  ');
  111.       if AFilter then write ('Poly-after ');
  112.       if BFilter then write ('Cont-ctrl ');
  113.       if CFilter then write ('Prgm-chng ');
  114.       if DFilter then write ('Aftertch ');
  115.       if EFilter then write ('Pitchbnd ');
  116.       if Ffilter then write ('System ');
  117.       if Nfilter then write ('Notes ');
  118.    end;
  119.  
  120. procedure FilterSetup;
  121.   var
  122.     choice: char;
  123.   begin
  124.     window(1,1,80,24);
  125.     clrscr;
  126.       writeln('Filter these types of messages: ');
  127.       writeln;
  128.       writeln('A) polyphonic key pressure     D) aftertouch');
  129.       writeln('B) continuous controllers      E) pitch bend');
  130.       writeln('C) program change              F) system messages');
  131.       writeln('N) notes');
  132.       writeln;
  133.       writeln('R) reset');
  134.       writeln;
  135.       writeln('Return to accept settings.');
  136.       writeln;
  137.    repeat
  138.       choice:=upcase(readkey);
  139.       case choice of
  140.         'A': Afilter:=true;
  141.         'B': BFilter:=true;
  142.         'C': Cfilter:=true;
  143.         'D': Dfilter:=true;
  144.         'E': Efilter:=true;
  145.         'F': Ffilter:=true;
  146.         'N': Nfilter:=true;
  147.         'R': InitFilters;
  148.       end;
  149.       ShowFilters;
  150.     until choice=#13;
  151.  
  152.     gotoxy(1,24); write ('Press any key to stop. ');
  153.     window(1,1,80,22);
  154.     clrscr;
  155.   end;
  156.  
  157. procedure PrintHex;
  158.   begin
  159.     write ( HexString(buffer[i]),'  ');
  160.   end;
  161.  
  162. procedure PrintDec;
  163.   begin
  164.     write ( buffer[i]:4 );
  165.   end;
  166.  
  167. procedure PrintLine;
  168.   begin
  169.     stattocome:=false;
  170.     BytesLeft:=2;
  171.     midich:=(buffer[i] and $0F)+1;
  172.     case buffer[i] of
  173.       $80..$8F: write ('Note Off   ');
  174.       $90..$9F: write ('Note On    ');
  175.       $A0..$AF: write ('Poly after ');
  176.       $B0..$BF: write ('Controller ');
  177.       $C0..$CF: begin write ('Program    '); dec(Bytesleft); end;
  178.       $D0..$DF: begin write ('Aftertouch '); dec(Bytesleft); end;
  179.       $E0..$EF: write ('Pitch Wheel');
  180.       $F0: begin  writeln ('System exclusive:  '); sysex:=true; end;
  181.       $F2:      write ('Song Pointer');
  182.       $F3: begin  write ('Song Select'); dec(BytesLeft); end;
  183.       $F6:      writeln ('Tune Request ');
  184.       $F7: begin writeln;writeln('End of sys-ex '); sysex:=false; end;
  185.       $F8:      writeln ('Clock  ');
  186.       $FA:      writeln ('Play ');
  187.       $FB:      writeln ('Continue ');
  188.       $FC:      writeln ('Stop ');
  189.       $FE:      writeln ('Active sensing ');
  190.       $FF:      writeln ('System reset  ');
  191.     end;
  192.     if buffer[i] in [$F6..$FF] then BytesLeft:=0;
  193.     statbytes:=bytesleft;
  194.   end;
  195.  
  196. procedure PrintLineData;
  197.   begin
  198.     if stattocome then begin
  199.       write('           ');
  200.       bytesleft:=statbytes;
  201.       stattocome:=false;
  202.     end;
  203.     write(buffer[i]:8);
  204.     dec(BytesLeft);
  205.     if BytesLeft=0 then begin
  206.       gotoxy(40,whereY);
  207.       writeln ('channel ',midich:2);
  208.       stattocome:=true;
  209.     end;
  210.   end;
  211.  
  212. procedure FileSave(N: integer);
  213.   var
  214.     j: integer; ch: char;
  215.   begin
  216.     LowVideo;
  217.     while keypressed do ch:=readkey;
  218.     writeln;
  219.     repeat
  220.       write ('Save data to filename (Return only for no save) : ');
  221.       readln (FileName);
  222.         if FileName = '' then exit;
  223.       if exist(Filename) then begin
  224.         writeln ('File exists! Overwrite? (y/n)');
  225.         ch:=upcase(readkey);
  226.       end;
  227.     until (exist(filename)=false) or (ch='Y');
  228.     assign (MidiFile, FileName);
  229.     rewrite (MidiFile);
  230.     for j:=0 to N-1 do
  231.       write (MidiFile, byte(buffer[j]));
  232.     close (MidiFile);
  233.   end;
  234.  
  235. procedure DataSend (N: integer);
  236.   begin
  237.     i:=0;
  238.     window(1,1,80,22);
  239.     repeat
  240.       write (HexString(buffer[i]),'  ');
  241.       PutData (buffer[i]);
  242.       inc(i);
  243.     until i = N;
  244.   end;
  245.  
  246. procedure Send;
  247.   var j:byte;
  248.   begin
  249.     LowVideo;
  250.     writeln;
  251.     repeat
  252.       write ('Send data from filename (Return only for no send) : ');
  253.       readln (FileName);
  254.         if FileName = '' then exit;
  255.       assign (MidiFile, FileName);
  256.       if IOResult<>0 then writeln ('Disk error!');
  257.     until IOResult=0;
  258.     reset (MidiFile);
  259.     i:=0;
  260.     repeat
  261.       read (MidiFile, j);
  262.       buffer[i]:=integer(j);
  263.       inc(i);
  264.     until eof (MidiFile) = true;
  265.     LastByte := i;
  266.     writeln (LastByte,' bytes to send');
  267.     close (MidiFile);
  268.     write('Press any key to send'); ch:=readkey;
  269.     DataSend (LastByte);
  270.   end;
  271.  
  272. procedure DisplayData;
  273.   begin
  274.     LowVideo;
  275.     case PrintFlag of
  276.       'H': PrintHex;
  277.       'D': PrintDec;
  278.       'L': if sysex=false then PrintLineData else printhex;
  279.     end;
  280.     inc(i);
  281.   end;
  282.  
  283. procedure DisplayStatus;
  284.   begin
  285.       HighVideo;
  286.       case PrintFlag of
  287.         'H': PrintHex;
  288.         'D': PrintDec;
  289.         'L': PrintLine;
  290.       end;
  291.     inc(i);
  292.   end;
  293.  
  294. procedure Skip;
  295.   begin
  296.     laststat:=buffer[i];
  297.     repeat
  298.       getdata(buffer[i]);
  299.     until (buffer[i]>$7F) and (buffer[i]<>laststat);
  300.     laststat:=buffer[i];
  301.     comingback:=true;
  302.   end;
  303.  
  304. procedure Receive;
  305.   begin
  306.     done:=false;   comingback:=false;
  307.     window(1,23,80,24);
  308.     clrscr;
  309.     LowVideo;
  310.     writeln ('Display data in H)ex, D)ecimal, or L)ine format? ');
  311.     PrintFlag := upcase(readkey);
  312.     write ('Press any key to quit');
  313.     ShowFilters;
  314.     window(1,1,80,23);
  315.     clrscr;
  316.     sysex:=false;
  317.     i:=0;
  318.     repeat
  319.       if comingback=false then getdata(buffer[i]);
  320.       if comingback then comingback:=false;
  321.       case buffer[i] of
  322.         $00..$7F: DisplayData;
  323.         $80..$9F: if Nfilter then Skip else DisplayStatus;
  324.         $A0..$AF: if Afilter then Skip else DisplayStatus;
  325.         $B0..$BF: if Bfilter then Skip else DisplayStatus;
  326.         $C0..$CF: if Cfilter then Skip else DisplayStatus;
  327.         $D0..$DF: if Dfilter then Skip else DisplayStatus;
  328.         $E0..$EF: if Efilter then Skip else DisplayStatus;
  329.         $F0: if Ffilter then Skip else DisplayStatus;
  330.         $F2: if Ffilter then Skip else DisplayStatus;
  331.         $F3: if Ffilter then Skip else DisplayStatus;
  332.         $F4..$FF: if Ffilter=false then DisplayStatus;
  333.       end;
  334.     until keypressed;                            { End loop.   }
  335.  
  336.     window(1,23,80,25);
  337.     FileSave(i);
  338.     window(1,1,80,25); clrscr;
  339.   end;
  340.  
  341. { **** MAIN PROGRAM **** }
  342.  
  343. begin
  344.   Hello;
  345.   quit:=false;
  346.   resetMPU;
  347.   putcmd($3f);
  348.     getdata(midijunk);  {empty ACK}
  349.   InitFilters;
  350.   repeat
  351.     ShowFilters;
  352.     window(1,23,80,24);
  353.     clrscr; LowVideo;
  354.     writeln ('R)eceive MIDI data         S)end data from a file');
  355.     write   ('F)ilters                   Q)uit ');
  356.     answer := upcase(readkey);
  357.     if answer = 'R' then Receive;
  358.     if answer = 'Q' then Quit := true;
  359.     if answer = 'F' then FilterSetup;
  360.     if answer = 'S' then Send;
  361.   until Quit=true;
  362.   clrscr;
  363.   resetMPU;
  364.   writeln ('So long!');
  365.   NormVideo;
  366. end.
  367.